Загрузим датасет:
insur <- read.csv("insurance_cost.csv")
head(insur)
## age sex bmi children smoker region charges
## 1 19 female 27.900 0 yes southwest 16884.924
## 2 18 male 33.770 1 no southeast 1725.552
## 3 28 male 33.000 3 no southeast 4449.462
## 4 33 male 22.705 0 no northwest 21984.471
## 5 32 male 28.880 0 no northwest 3866.855
## 6 31 female 25.740 0 no southeast 3756.622
Это данные по базовым показателям здоровья индивида и сумме, которую страховая компания заплатила за его лечение в год.
Вспомним немного описание данных:
skimr::skim(insur)
| Name | insur |
| Number of rows | 1338 |
| Number of columns | 7 |
| _______________________ | |
| Column type frequency: | |
| character | 3 |
| numeric | 4 |
| ________________________ | |
| Group variables | None |
Variable type: character
| skim_variable | n_missing | complete_rate | min | max | empty | n_unique | whitespace |
|---|---|---|---|---|---|---|---|
| sex | 0 | 1 | 4 | 6 | 0 | 2 | 0 |
| smoker | 0 | 1 | 2 | 3 | 0 | 2 | 0 |
| region | 0 | 1 | 9 | 9 | 0 | 4 | 0 |
Variable type: numeric
| skim_variable | n_missing | complete_rate | mean | sd | p0 | p25 | p50 | p75 | p100 | hist |
|---|---|---|---|---|---|---|---|---|---|---|
| age | 0 | 1 | 39.21 | 14.05 | 18.00 | 27.00 | 39.00 | 51.00 | 64.00 | ▇▅▅▆▆ |
| bmi | 0 | 1 | 30.66 | 6.10 | 15.96 | 26.30 | 30.40 | 34.69 | 53.13 | ▂▇▇▂▁ |
| children | 0 | 1 | 1.09 | 1.21 | 0.00 | 0.00 | 1.00 | 2.00 | 5.00 | ▇▂▂▁▁ |
| charges | 0 | 1 | 13270.42 | 12110.01 | 1121.87 | 4740.29 | 9382.03 | 16639.91 | 63770.43 | ▇▂▁▁▁ |
Нулевых значений в возрасте, ИМТ и выплатах нет. Чистить не нужно.
Сделаем интерактивный график отношения ИМТ и затрат на страховку:
plot_ly(data = insur,
x = ~ bmi,
y = ~ charges,
type = "scatter",
mode = 'markers',#без этой строки у меня не работает интерактив
color = ~ smoker,
colors = "Set2"#и без указания палетки тоже не сработало бы
)
То же через ggplotly:
plot <- insur %>%
ggplot(aes(x=bmi, y=charges, color = smoker)) +
geom_point() +
theme_dark()
ggplotly(plot)
Корреляционный анализ
Сначала матрицу строим:
insur_num <- insur %>%
select(is.integer | is.numeric)
#head(insur_num)
insur_cor <- cor(insur_num)
insur_cor
## age children bmi charges
## age 1.0000000 0.04246900 0.1092719 0.29900819
## children 0.0424690 1.00000000 0.0127589 0.06799823
## bmi 0.1092719 0.01275890 1.0000000 0.19834097
## charges 0.2990082 0.06799823 0.1983410 1.00000000
И нарисуем:
corrplot(insur_cor, method = 'number')
из пакета corpplot:
corrplot(insur_cor,
order = "alphabet",
cl.pos = 'b',
tl.pos = 'd',
col = COL1('Blues'),
diag = FALSE)
Для себя описание параметров: order = “AOE” - порядок, в котором выводят названия переменных (в алфавитном)
cl.pos = ‘b’ - определяет положение цветной шкалы (сейчас снизу).
tl.pos = ‘d’ - определяет положение текстовых надписей переменных (по диагонали)
col = COL1(‘Blues’) - настройка палитры графика:
COL1() - для визуализации неотрицательной или неположительной матрицы.
COL2() - для визуализации матрицы, элементы которой частично положительные, а частично отрицательные.
Цветовые палитры у них отличаются и не работают, если указана неверная.
diag = FALSE - нужно ли обозначать корреляцию на ячейках по диагонали, в данном случае работает и без этого т.к. там у нас текст, но в ином случае можно выбрать показывать или нет.
Для себя оставлю ссылку
из пакета corrr:
insur_cor%>%
rplot(print_cor = TRUE, colors = c("cyan", "blue"), legend = TRUE)
Выглядит плохо, но хотелось посмотреть corrr.
Создадим новый датафрейм (номинативные в дамми/бинарные):
library('fastDummies')
insur_wD <- dummy_cols(insur, select_columns = c('sex', 'smoker', 'region'))
#хотя можно и через mutate с case_when
insur_wD <- insur_wD %>%
select(is.numeric)
head(insur_wD)
## age bmi children charges sex_female sex_male smoker_no smoker_yes
## 1 19 27.900 0 16884.924 1 0 0 1
## 2 18 33.770 1 1725.552 0 1 1 0
## 3 28 33.000 3 4449.462 0 1 1 0
## 4 33 22.705 0 21984.471 0 1 1 0
## 5 32 28.880 0 3866.855 0 1 1 0
## 6 31 25.740 0 3756.622 1 0 1 0
## region_northeast region_northwest region_southeast region_southwest
## 1 0 0 0 1
## 2 0 0 1 0
## 3 0 0 1 0
## 4 0 1 0 0
## 5 0 1 0 0
## 6 0 0 1 0
Иерархическая кластеризация
Отшкалируем данные:
insur_sc <- scale(insur_wD)
head(insur_sc)
## age bmi children charges sex_female sex_male
## [1,] -1.4382265 -0.4531506 -0.90827406 0.2984722 1.0101410 -1.0101410
## [2,] -1.5094011 0.5094306 -0.07873775 -0.9533327 -0.9892209 0.9892209
## [3,] -0.7976553 0.3831636 1.58033487 -0.7284023 -0.9892209 0.9892209
## [4,] -0.4417824 -1.3050431 -0.90827406 0.7195739 -0.9892209 0.9892209
## [5,] -0.5129570 -0.2924471 -0.90827406 -0.7765118 -0.9892209 0.9892209
## [6,] -0.5841316 -0.8073542 -0.90827406 -0.7856145 1.0101410 -1.0101410
## smoker_no smoker_yes region_northeast region_northwest region_southeast
## [1,] -1.9698501 1.9698501 -0.5650556 -0.5662062 -0.6110952
## [2,] 0.5072734 -0.5072734 -0.5650556 -0.5662062 1.6351833
## [3,] 0.5072734 -0.5072734 -0.5650556 -0.5662062 1.6351833
## [4,] 0.5072734 -0.5072734 -0.5650556 1.7648211 -0.6110952
## [5,] 0.5072734 -0.5072734 -0.5650556 1.7648211 -0.6110952
## [6,] 0.5072734 -0.5072734 -0.5650556 -0.5662062 1.6351833
## region_southwest
## [1,] 1.7648211
## [2,] -0.5662062
## [3,] -0.5662062
## [4,] -0.5662062
## [5,] -0.5662062
## [6,] -0.5662062
Сначала создади матрицу дистанций:
Расчёт дендрограммы кластеров:
insur_hc <- hclust(d = insur_dist,
method = "ward.D2")
Визуализация:
fviz_dend(insur_hc,
cex = 0.1)
Доп. визуализация матрицы дистанций:
fviz_dist(insur_dist, gradient = list(low = "blue", mid = "white", high = "red"))
#Задание 7
Раскраска кластеров:
insur_sc <- scale(insur_wD)
# Разбиваем на 5 групп дерево
grp <- cutree(insur_hc, k = 5)
head(grp, n = 5)#вектор с номерами кластера
## [1] 1 2 2 3 3
# сколько в каждой группе
table(grp)
## grp
## 1 2 3 4 5
## 274 273 267 257 267
df<-as.data.frame(insur_sc)
# добавим группы
df$grp <- grp
Просто покрашена:
fviz_dend(insur_hc, k = 5, # Cut in four groups
cex = 0.5, # label size
k_colors = c("#2E9FDF", "#00CC33", "#E7B800", "#FC4E07", "#660099"),
color_labels_by_k = TRUE # color labels by groups
)
## Warning: `guides(<scale> = FALSE)` is deprecated. Please use `guides(<scale> =
## "none")` instead.
Покрашена + границы
fviz_dend(insur_hc, k = 5, # Cut in four groups
cex = 0.5, # label size
k_colors = c("#2E9FDF", "#00CC33", "#E7B800", "#FC4E07", "#660099"),
color_labels_by_k = TRUE, # color labels by groups
rect = TRUE, # Add rectangle around groups
rect_border = "black"
)
## Warning: `guides(<scale> = FALSE)` is deprecated. Please use `guides(<scale> =
## "none")` instead.
Покрашена и закрашена:
fviz_dend(insur_hc, k = 5,
rect = TRUE,
rect_fill = TRUE,
rect_border = "jco",
k_colors = "jco",
cex = 0.1
)
phylogenic-like tree:
fviz_dend(insur_hc, k = 5, k_colors = "jco", type = "phylogenic", relep = TRUE , phylo_layout = "layout_as_tree")
Scatter plot:
fviz_cluster(list(data = df, cluster = grp)
)
(видимо из-за переменных даммис кластеры разбиваются, когда строила без них для каждого кластера было одно облачко)
#Задание 8
Одновременно heat map и tree map:
pheatmap(insur_sc, cutree_rows = 6)#с разбиением на подгруппы
Можно заметить, что бОльшие значения charges соответствует курящим (оранжевые прямоугольники по charges и оранжевые по smoker_yes)
library("d3heatmap")
d3heatmap(insur_sc, colors = "RdYlBu",
k_row = 6, # Number of groups in rows
k_col = 2 # Number of groups in columns
)
Должно было быть красиво, но видимо из-за объёма данных не закрасились прямоугольнички, но интерактив работает. Исходный пример:
d3heatmap(scale(mtcars), colors = "RdYlBu",
k_row = 6, # Number of groups in rows
k_col = 2 # Number of groups in columns
)
#Задание 9
Проведём анализ PCA
insur.pca <- prcomp(insur_wD, scale = T)
insur.pca$rotation#веса главных компонент
## PC1 PC2 PC3 PC4
## age 0.074783666 -0.058852219 0.105524125 0.1014109474
## bmi 0.093561955 0.038801873 0.521403475 0.0303771541
## children 0.027785271 0.011309807 -0.013233447 0.1238890238
## charges 0.533651705 -0.130821961 0.005749107 0.0484819280
## sex_female -0.152794587 -0.687701110 0.043685850 0.0007434309
## sex_male 0.152794587 0.687701110 -0.043685850 -0.0007434309
## smoker_no -0.564890399 0.124959968 0.118482771 -0.0174463686
## smoker_yes 0.564890399 -0.124959968 -0.118482771 0.0174463686
## region_northeast -0.006005881 -0.016701389 -0.363891193 -0.4220767696
## region_northwest -0.053941542 -0.009346488 -0.320389371 -0.1046530598
## region_southeast 0.101144455 0.012583875 0.670590572 -0.2956203900
## region_southwest -0.045019353 0.012971745 -0.011991395 0.8330616582
## PC5 PC6 PC7 PC8 PC9
## age -0.004177559 -0.78397855 0.31617636 -0.416750321 0.28501957
## bmi 0.007919532 -0.24450746 0.08742266 0.789045636 0.16393250
## children -0.087753149 -0.33721190 -0.92752433 -0.009471695 0.04210556
## charges -0.012177926 -0.21486417 0.06329618 0.030802089 -0.80277508
## sex_female 0.002544583 0.02006494 -0.02110925 0.030541334 0.00495393
## sex_male -0.002544583 -0.02006494 0.02110925 -0.030541334 -0.00495393
## smoker_no 0.012646442 -0.16745420 0.02438755 0.001106765 -0.34949175
## smoker_yes -0.012646442 0.16745420 -0.02438755 -0.001106765 0.34949175
## region_northeast 0.603158292 -0.21025889 -0.03307944 0.186068805 0.02229031
## region_northwest -0.763269598 -0.10936580 0.09955064 0.182689049 0.01275974
## region_southeast -0.045577126 0.20086158 -0.11194087 -0.364324587 -0.02373964
## region_southwest 0.208039464 0.11096476 0.04965841 0.009506976 -0.01039141
## PC10 PC11 PC12
## age 1.306025e-16 -1.951155e-16 -4.133818e-16
## bmi 2.016792e-16 1.319054e-16 -2.353279e-16
## children -1.697237e-16 -1.707754e-16 3.572821e-17
## charges -2.529172e-16 3.175752e-16 1.350921e-15
## sex_female -7.051097e-01 -5.292035e-02 4.439052e-03
## sex_male -7.051097e-01 -5.292035e-02 4.439052e-03
## smoker_no 2.375034e-03 2.762286e-02 7.065630e-01
## smoker_yes 2.375034e-03 2.762286e-02 7.065630e-01
## region_northeast -3.712941e-02 4.931050e-01 -1.915298e-02
## region_northwest -3.716832e-02 4.936218e-01 -1.917305e-02
## region_southeast -3.857063e-02 5.122454e-01 -1.989642e-02
## region_southwest -3.716832e-02 4.936218e-01 -1.917305e-02
summary(insur.pca)
## Importance of components:
## PC1 PC2 PC3 PC4 PC5 PC6 PC7
## Standard deviation 1.6737 1.4023 1.2417 1.1513 1.1498 1.07055 0.98583
## Proportion of Variance 0.2334 0.1639 0.1285 0.1105 0.1102 0.09551 0.08099
## Cumulative Proportion 0.2334 0.3973 0.5258 0.6363 0.7465 0.84196 0.92295
## PC8 PC9 PC10 PC11 PC12
## Standard deviation 0.87032 0.40877 2.012e-15 1.043e-15 7.413e-16
## Proportion of Variance 0.06312 0.01392 0.000e+00 0.000e+00 0.000e+00
## Cumulative Proportion 0.98608 1.00000 1.000e+00 1.000e+00 1.000e+00
fviz_eig(insur.pca,
addlabels = T,
ylim = c(0, 40))
60% (объясняем 2/3 данных) достигается на PC4. 90% - на PC7.Не очень хорошо.
Резко падает прирост % на 9-10 компонентах (было 6,3%, а упало до 1,4%) и если бы надо было уменьшать размерность (количество переменных), то выкинула бы их.
Анализ компонент (как каждая переменная влияет на главные компоненты):
fviz_pca_var(insur.pca, col.var = "contrib")
очевидно, что пол Ж/М отрицательно скоррелированы, аналогично (не)курящие.
На первую компоненту (Dim1) влияют (не)курящие и выплаты (по этой оси идёт бОльшая вариация этих признаков). На вторую компоненту (Dim2) - пол. Что касается остальных переменных, то они вносят малый вклад в первые две компоненты. А выплаты скореллированы с курящими. Т.е. в целом сильно выражен эффект от пола и курения.
Посмотрим на топ 5 самых важных переменных с т.з. их вариации в PC1 и PC2:
fviz_pca_var(insur.pca,
select.var = list(contrib = 5),
col.var = "contrib")
Итого важны пол, отношение к курению, выплаты.
Посмотрим из чего состоят 1, 2 и 3 главные компоненты:
fviz_contrib(insur.pca, choice = "var", axes = 1) # 1
fviz_contrib(insur.pca, choice = "var", axes = 2) # 2
fviz_contrib(insur.pca, choice = "var", axes = 3) # 3
Как и на диаграмме выше видим, что для самой первой компоненты (PC1) бОльший вклад приходит от курящих (по факту бинарные данные, которые, как мы обсуждали на лекции, сильно влияют на анализ), на вторую компоненту пол, а на третью уже регион, ИМТ.
Сделаем biplot. Посмотрим, наблюдается ли разница между группами по age:
library(ggbiplot)
# Сделаем корректные данные для группировки по age
insur_w_ch <- insur_wD %>%
mutate(
age_group = case_when(
age <20 ~ "до 20",
age >19 & age < 36 ~ "20-35",
age > 35 & age < 51 ~ "36-50",
age > 50 ~ "после 50"
))
# Визуализируем с группировкой по возрастным группам (для этого переменную нужно сделать фактором)
ggbiplot(insur.pca,
scale=0,
groups = as.factor(insur_w_ch$age_group),
ellipse = T,
alpha = 0.2) +
theme_minimal()
Не очень кластеризуются по возрастным группам (до чего, наверно, можно было догадаться по тому, что вектор age невелик), но, если правильно понимаю график, то у мы видим 4 какие-то кластера, которые, по-видимому, кластеризуются на основании какого-то другого параметра.
Сделаю доп кластеризацию, по другому параметру, просто чтобы проверить эти 4 облака точек.Судя по их расположению, можно предположить, что стоит поиграть с полом и курением:
# Сделаем корректные данные для группировки по age и smoker
insur_w_ch <- insur_wD %>%
mutate(
clust_m_s = case_when(
(sex_male == 1) & (smoker_yes == 1) ~ "1-1",
(sex_male == 1) & (smoker_yes == 0) ~ "1-0",
(sex_male == 0) & (smoker_yes == 1) ~ "0-1",
(sex_male == 0) & (smoker_yes == 0) ~ "0-0"
))
#сделаем так, что комбинации пола и курения такие: М-курит = 1-1, М-не_курит = 1-0, Ж-курит = 0-1, Ж-не_курит = 0-0
# Визуализируем с такой группировкой
ggbiplot(insur.pca,
scale=0,
groups = as.factor(insur_w_ch$clust_m_s),
ellipse = T,
alpha = 0.2) +
theme_minimal()
Кластеры выделились согласно облачкам.
#Задание 11 Видимо, это как раз про то, чего я пыталась добиться выше. Но посмотрю ещё дополнительно
Отдельно по полу:
insur_w_ch <- insur_wD %>%
mutate(
sex = case_when(
sex_male == 1 ~ "male",
sex_male == 0 ~ "female"
))
# по факту просто вернулись к исходной переменной пол
ggbiplot(insur.pca,
scale=0,
groups = as.factor(insur_w_ch$sex),
ellipse = T,
alpha = 0.2) +
theme_minimal()
Разбилось (как раз вдоль направления пола)
Отдельно по курению:
insur_w_ch <- insur_wD %>%
mutate(
smoker = case_when(
smoker_yes == 1 ~ "male",
smoker_yes == 0 ~ "female"
))
# по факту просто вернулись к исходной переменной smoker
ggbiplot(insur.pca,
scale=0,
groups = as.factor(insur_w_ch$smoker),
ellipse = T,
alpha = 0.2) +
theme_minimal()
Разбилось по другому направлению.
Отдельно по выплатам:
insur_w_ch <- insur_wD %>%
mutate(
charg_group = case_when(
charges <=5000 ~ "<= 5K",
charges >5000 & charges <= 15000 ~ "5K-15K",
charges > 15000 & charges < 50000 ~ "15K-50K",
charges > 50000 ~ "после 50"
))
# по факту просто вернулись к исходной переменной smoker
ggbiplot(insur.pca,
scale=0,
groups = as.factor(insur_w_ch$charg_group),
ellipse = T,
alpha = 0.2) +
theme_minimal()
Можно было бы взять и 2 градации для выплат, как раз было бы до 0 и после.
#Задание 12
Наверно стоит для начала взглянуть по каким переменным самый большой разброс (закоменченные library(psych) и describe. Там по sd идёт charges, age, bmi, children… Попробую удалить те, что с не самым большим разбросом (как раз пол, регион, курение, хотя наверно я много удаляю)
#смотрю разброс данных
#library(psych)
#describe(insur_wD)
insur_v_1 <- insur_wD %>%
select( 'age', 'bmi', 'children', 'charges')
#PCA
insur.pca_1 <- prcomp(insur_v_1, scale = T)
summary(insur.pca_1)
## Importance of components:
## PC1 PC2 PC3 PC4
## Standard deviation 1.195 0.9962 0.9468 0.8264
## Proportion of Variance 0.357 0.2481 0.2241 0.1707
## Cumulative Proportion 0.357 0.6051 0.8293 1.0000
#Приходим к тому, что у нас на 2 компоненте достигается 60%, он наверно потому что мы много удалили
fviz_eig(insur.pca_1,
addlabels = T,
ylim = c(0, 40))
fviz_contrib(insur.pca_1, choice = "var", axes = 1) # 1
fviz_contrib(insur.pca_1, choice = "var", axes = 2) # 2
fviz_contrib(insur.pca_1, choice = "var", axes = 3) # 3
ggbiplot(insur.pca_1,
scale=0) +
theme_minimal()
Много удалилось данных, поэтому наверно пример не очень.
Если не будем ничего удалять, а заменим возраст на даммис
insur_v_2 <- insur_wD %>%
mutate(
age_group = case_when(
age <20 ~ "до 20",
age >19 & age < 36 ~ "20-35",
age > 35 & age < 51 ~ "36-50",
age > 50 ~ "после 50"
))
#и делаем их дамми
insur_v_2 <- dummy_cols(insur_v_2, select_columns = "age_group")
insur_v_2$age <- NULL
insur_v_2$age_group <- NULL
#PCA
insur.pca_2 <- prcomp(insur_v_2, scale = T)
summary(insur.pca_2)
## Importance of components:
## PC1 PC2 PC3 PC4 PC5 PC6 PC7
## Standard deviation 1.6753 1.4037 1.2577 1.2318 1.20723 1.15450 1.14923
## Proportion of Variance 0.1871 0.1313 0.1055 0.1012 0.09716 0.08886 0.08805
## Cumulative Proportion 0.1871 0.3185 0.4239 0.5251 0.62224 0.71110 0.79915
## PC8 PC9 PC10 PC11 PC12 PC13
## Standard deviation 1.11835 0.90338 0.8789 0.41658 1.097e-15 7.85e-16
## Proportion of Variance 0.08338 0.05441 0.0515 0.01157 0.000e+00 0.00e+00
## Cumulative Proportion 0.88253 0.93693 0.9884 1.00000 1.000e+00 1.00e+00
## PC14 PC15
## Standard deviation 6.591e-16 2.725e-16
## Proportion of Variance 0.000e+00 0.000e+00
## Cumulative Proportion 1.000e+00 1.000e+00
fviz_eig(insur.pca_2,
addlabels = T,
ylim = c(0, 40))
fviz_contrib(insur.pca_2, choice = "var", axes = 1) # 1
fviz_contrib(insur.pca_2, choice = "var", axes = 2) # 2
fviz_contrib(insur.pca_2, choice = "var", axes = 3) # 3
ggbiplot(insur.pca_2,
scale=0) +
theme_minimal()
Не сильно качество изменило, но наверно потому что изначально возраст не сильно влиял на компоненты.
Изначально у нас даммиес-переменные сильно влияют на PCA, попробуем с ними что-то сделать. Просто сделаем бинарными smoker (yes=1, no=0) и sex (male=1, female=0)
insur_v_3 <- insur %>%
mutate(
smoker = if_else(smoker == 'yes', 1, 0),
sex = if_else(sex == 'female', 1, 0),
)
#и делаем их дамми
insur_v_3 <- dummy_cols(insur_v_3, select_columns = "region" )
insur_v_3$region <- NULL
#PCA
insur.pca_3 <- prcomp(insur_v_3, scale = T)
summary(insur.pca_3)
## Importance of components:
## PC1 PC2 PC3 PC4 PC5 PC6 PC7 PC8
## Standard deviation 1.3939 1.2182 1.1510 1.1496 1.0403 1.0018 0.9767 0.86822
## Proportion of Variance 0.1943 0.1484 0.1325 0.1321 0.1082 0.1004 0.0954 0.07538
## Cumulative Proportion 0.1943 0.3427 0.4752 0.6073 0.7156 0.8159 0.9113 0.98669
## PC9 PC10
## Standard deviation 0.36478 9.986e-16
## Proportion of Variance 0.01331 0.000e+00
## Cumulative Proportion 1.00000 1.000e+00
#Приходим к тому, что у нас на 2 компоненте достигается 60%, он наверно потому что мы много удалили
fviz_eig(insur.pca_3,
addlabels = T,
ylim = c(0, 40))
fviz_contrib(insur.pca_3, choice = "var", axes = 1) # 1
fviz_contrib(insur.pca_3, choice = "var", axes = 2) # 2
fviz_contrib(insur.pca_3, choice = "var", axes = 3) # 3
ggbiplot(insur.pca_3,
scale=0) +
theme_minimal()
Качество не улучшилось, а похоже стало даже хуже. Хотя мы ничего не изменили сильно, кроме как теперь не отдельные колонки для курящих и некурящих, а в одной колонке 1 и 0.
В Dim1 третий по важности ИМТ(bmi), а в Dim2 он второй - попробуем его сделать дамми в добавок к тому, что делали выше:
insur_v_4 <- insur %>%
mutate(
smoker = if_else(smoker == 'yes', 1, 0),
sex = if_else(sex == 'female', 1, 0),
bmi_group = case_when(
bmi <18.5 ~ "und",
bmi >=18.5 & bmi <=24.9 ~ "norm",
bmi > 24.9 & bmi <= 29 ~ "over",
bmi > 29 ~ "obe"
))
#и делаем их дамми
insur_v_4 <- dummy_cols(insur_v_4, select_columns = "bmi_group")
insur_v_4$bmi <- NULL
insur_v_4$bmi_group <- NULL
insur_v_4$region <- NULL
#PCA
insur.pca_4 <- prcomp(insur_v_4, scale = T)
summary(insur.pca_4)
## Importance of components:
## PC1 PC2 PC3 PC4 PC5 PC6 PC7 PC8
## Standard deviation 1.4119 1.2731 1.1244 1.0344 1.0106 0.9979 0.9491 0.36559
## Proportion of Variance 0.2215 0.1801 0.1405 0.1189 0.1135 0.1106 0.1001 0.01485
## Cumulative Proportion 0.2215 0.4016 0.5421 0.6610 0.7744 0.8851 0.9851 1.00000
## PC9
## Standard deviation 1.316e-15
## Proportion of Variance 0.000e+00
## Cumulative Proportion 1.000e+00
fviz_eig(insur.pca_4,
addlabels = T,
ylim = c(0, 40))
fviz_contrib(insur.pca_4, choice = "var", axes = 1) # 1
fviz_contrib(insur.pca_4, choice = "var", axes = 2) # 2
fviz_contrib(insur.pca_4, choice = "var", axes = 3) # 3
ggbiplot(insur.pca_4,
scale=0) +
theme_minimal()
Поменялся порядо параметров в Dim1 (теперь ИМТ соответствующий сильному ожирению важен)
Если просто регионы вырзать
insur_v_5 <- insur_wD %>%
select(!contains("region"))
#PCA
insur.pca_5 <- prcomp(insur_v_5, scale = T)
summary(insur.pca_5)
## Importance of components:
## PC1 PC2 PC3 PC4 PC5 PC6 PC7
## Standard deviation 1.6672 1.4022 1.0984 0.9961 0.9419 0.41050 2.045e-15
## Proportion of Variance 0.3475 0.2458 0.1508 0.1240 0.1109 0.02106 0.000e+00
## Cumulative Proportion 0.3475 0.5932 0.7440 0.8680 0.9789 1.00000 1.000e+00
## PC8
## Standard deviation 7.479e-16
## Proportion of Variance 0.000e+00
## Cumulative Proportion 1.000e+00
fviz_eig(insur.pca_5,
addlabels = T,
ylim = c(0, 40))
fviz_contrib(insur.pca_5, choice = "var", axes = 1) # 1
fviz_contrib(insur.pca_5, choice = "var", axes = 2) # 2
fviz_contrib(insur.pca_5, choice = "var", axes = 3) # 3
ggbiplot(insur.pca_5,
scale=0) +
theme_minimal()
60% достигается на 3, а 90% на 5ой. Так что вроде как стало лучше